#lang racket


(require "../base/main.rkt"
         "../backends/main.rkt"
         "../ast/main.rkt")
(require (only-in "../constructors/main.rkt"
                  generic-evaluate
                  generic-evaluate-toplevel))
(require "../geometry/main.rkt"
         "../parametrization/main.rkt")

(require "rh-global.rkt"
         (prefix-in mar: "rh-marshal.rkt"))

(provide load-rhino-proxy)

(provide layer)


; exception

(define-struct (backend-exn exn:fail) ())

(define (raise-backend-exn msg)
  (raise (make-backend-exn msg (current-continuation-marks))))

(define (align-type-msg type)
  (format "Unhandled align type, given ~A" type))

(define (circle-msg type)
  (format "A circle can only be a line or surface, not ~A" type))

(define line-msg
  "Warning: Line: Rhino cannot make an open curve/polycurve with equal start and end coord; a close curve will be created instead")


; defer

(struct defer ())
(struct defer-intersect defer (shape1 shape2))
(struct defer-subtract defer (shape1 shape2))
(struct defer-union defer (shape1 shape2))

(define (list<-defer defer)
  (match defer
    ((defer-intersect shape1 shape2)
     (list shape1 shape2))
    ((defer-subtract shape1 shape2)
     (list shape1 shape2))
    ((defer-union shape1 shape2)
     (list shape1 shape2))))

(define (defer-dispatch shape1 shape2 shape-shape-fn shape-defer-fn defer-shape-fn defer-defer-fn)
  (cond ((and (defer? shape1) (defer? shape2)) defer-defer-fn)
        ((defer? shape1) defer-shape-fn)
        ((defer? shape2) shape-defer-fn)
        (else shape-shape-fn)))

(define (defer-subdispatch defer defer-intersect-fn defer-subtract-fn defer-union-fn)
  (match defer
    ((defer-intersect _ _) (defer-intersect-fn))
    ((defer-subtract _ _) (defer-subtract-fn))
    ((defer-union _ _) (defer-union-fn))))

(define (delete-defer-shapes defer)
  (if (shape? defer)
      (delete defer)
      (map delete-defer-shapes (list<-defer defer))))

;(define (replace-defer defer)
;  (match defer
;    ((defer-intersect _ _)
;     (error 'replace-defer "Not implemented"))
;    ((defer-subtract shape1 shape2)
;     (delete-defer-shapes shape2)
;     (list shape1))
;    ((defer-union shape1 shape2)
;     (append
;      (replace-defer shape1)
;      (replace-defer shape2)))
;    (else
;     (list defer))))

; edit: replace 'empty-region with a shape
(define (replace-defer defer/shape)
  (match defer/shape
    ((defer-intersect shape1 shape2)
     (let ((shape1 (replace-defer shape1))
           (shape2 (replace-defer shape2)))
       (cond ((and (eq? shape1 'empty-region) (eq? shape 'empty-region))
              'empty-region)
             ((eq? shape1 'empty-region)
              (delete shape2)
              shape1)
             ((eq? shape2 'empty-region)
              (delete shape1)
              shape2)
             ((mar:object-in-box? shape2 (mar:object-bounding-box shape1))
              (delete shape1)
              shape2)
             ((mar:object-in-box? shape1 (mar:object-bounding-box shape2))
              (delete shape2)
              shape1)
             (else
              (delete shape1)
              (delete shape2)
              'empty-region))))
    ((defer-subtract shape1 shape2)
     (let ((shape1 (replace-defer shape1))
           (shape2 (replace-defer shape2)))
       (cond ((and (eq? shape1 'empty-region) (eq? shape2 'empty-region))
              'empty-region)
             ((eq? shape1 'empty-region)
              (delete shape2)
              'empty-region)
             ((eq? shape2 'empty-region)
              shape1)
             ((mar:object-in-box? shape2 (mar:object-bounding-box shape1))
              (delete shape2)
              shape1)
             ((mar:object-in-box? shape1 (mar:object-bounding-box shape2))
              (delete shape1)
              (delete shape2)
              'empty-region)
             (else     
              (delete shape2)
              shape1))))
    ((defer-union shape1 shape2)
     (let ((shape1 (replace-defer shape1))
           (shape2 (replace-defer shape2)))
       (cond ((and (eq? shape1 'empty-region) (eq? shape2 'empty-region))
              'empty-region)
             ((eq? shape1 'empty-region)
              shape2)
             ((eq? shape2 'empty-region)
              shape1)
             ((mar:object-in-box? shape2 (mar:object-bounding-box shape1))
              (delete shape2)
              shape1)
             ((mar:object-in-box? shape1 (mar:object-bounding-box shape2))
              (delete shape1)
              shape2)
             (else
              (mar:join-shapes shape1 shape2)))))
    (else
     defer/shape)))

(define (replace-defers expr)
  (if (rhino-replace-defer?)
      (cond ((defer? expr) (replace-defer expr))
            ((list? expr) (map-tree replace-defer expr))
            (else expr))
      expr))

; /defer


; points

(define (point c)
  (mar:add-point c))


; lines

(define (arc angle radius)
  (mar:add-arc (mar:world-xy-plane) radius (degrees<-radians angle)))

(define (elliptical-arc angle x-radius y-radius)
  (scale (xyz x-radius y-radius 1) (arc angle 1)))

(define (ellipse x-radius y-radius)
  (mar:add-ellipse (mar:world-xy-plane) x-radius y-radius))

(define (line closed? coords)
  (define (open-line)
    (when (eq-c (first coords) (last coords))
      (displayln line-msg))
    (mar:add-polyline coords))
  
  (define (closed-line)
    (let ((shape (mar:add-polyline coords)))
      (cond ((mar:is-curve-closed? shape)
             shape)
            ((mar:is-curve-closable? shape)
             (mar:close-curve shape))
            (else
             (delete shape)
             (mar:add-polyline (append-first coords))))))
  
  (if closed?
      (closed-line)
      (open-line)))

(define (spline closed? cs type)
  (match type
    ((auto-spline-type)
     (if closed?
         (mar:add-interp-curve (append-first cs))
         (mar:add-interp-curve cs)))
    ((tangent-spline-type begin-tangent end-tangent)
     (if closed?
         (mar:add-interp-curve (append-first cs) begin-tangent end-tangent)
         (mar:add-interp-curve cs begin-tangent end-tangent)))))


; surfaces

; surface

(define (surface-msg shapes)
  (format "Surface: parameter (shapes) must be 1 closed curve or a list of 2, 3 or 4 coords or lines, given ~A" shapes))

(define (surface-from-list shapes)
  (cond
    ((andmap is-coord shapes)
     (mar:add-surface-coords shapes))
    ((andmap mar:is-curve? shapes)
     (mar:add-edge-surface shapes))
    (else
     (error 'surface (surface-msg shapes)))))

(define (surface shapes)
  (cond ((list? shapes)
         (surface-from-list shapes))
        ((mar:is-curve-closed? shapes)
         (mar:add-planar-surface shapes))
        ; edit: hack or correct? perhaps introduce the concept of polysurface
        (else
         (mar:add-edge-surface (list shapes)))))

; /surface


; solids

(define (box width length height)
  (mar:add-box (flatten (map list-of-coord (box-corners width length height)))))

(define (cone radius height)
  (mar:add-cone
   u0
   (mult-c uz height)
   radius
   true))

;(define (cone-frustrum base-radius top-radius height)
;  (define (normal-cone base-radius top-radius height)
;    (let ((top-height 
;           (/
;            (* height top-radius)
;            (- base-radius top-radius))))
;      (subtract
;       (cone base-radius (+ height top-height))
;       (move
;        (mult-c uz (+ height (/ top-height 2)))
;        (box (+ (*2 top-height) 1) (+ (*2 top-height) 1) top-height)))))
;  
;  (define (inverted-cone base-radius top-radius height)
;    (rotate pi ux
;            (move
;             (mult-c uz (- height))
;             (normal-cone base-radius top-radius height))))
;  
;  (if (< top-radius base-radius)
;      (normal-cone base-radius top-radius height)
;      (inverted-cone top-radius base-radius height)))

(define (cone-frustrum base-radius top-radius height)
  (define (normal-cone base-radius top-radius height)
    (loft
     #f
     (list (circle (surface-primitive-type) base-radius)
           (move (z height) (circle (surface-primitive-type) top-radius)))))
  
  (define (inverted-cone base-radius top-radius height)
    (rotate pi ux
            (move
             (mult-c uz (- height))
             (normal-cone base-radius top-radius height))))
  
  (if (< top-radius base-radius)
      (normal-cone base-radius top-radius height)
      (inverted-cone top-radius base-radius height)))

(define (cylinder radius height)
  (mar:add-cylinder u0 (mult-c uz height) radius true))

(define (pyramid width sides height)
  (if (= sides 4)
      (mar:join-surfaces
       (list
        (mar:add-planar-surface (rectangle width width))
        (mar:extrude-curve-coord
         (rectangle width width)
         (mult-c uz height)))
       #t)
      (error 'pyramid "Only 4-sided pyramids are implemented")))

(define (sphere radius)
  (mar:add-sphere u0 radius))


; generic shapes

(define (circle type radius)
  (match type
    ((line-primitive-type) (mar:add-circle (mar:world-xy-plane) radius))
    ((surface-primitive-type) (mar:add-planar-surface (circle (line-primitive-type) radius)))
    (else (raise-backend-exn (circle-msg type)))))

(define (rectangle type width length)
  (match type
    ((line-primitive-type) (line #t (rectangle-coords width length)))
    ((surface-primitive-type) (surface (rectangle (line-primitive-type) width length)))))


; transformations

(define (extrude length shape)
  (if (mar:is-curve? shape)
      (mar:extrude-curve-straight shape u0 (add-z-c u0 length))
      (error 'extrude "Implemented only for curves")))


; intersect

; edit: refactor because is-surface? also recognizes solids
(define (rh-intersect shape1 shape2)
  (cond ((and (mar:is-object-solid? shape1) (mar:is-object-solid? shape2))
         (mar:boolean-intersection shape1 shape2 #t))
        ((and (mar:is-surface? shape1) (mar:is-surface? shape2))
         (mar:intersect-breps shape1 shape2))
        (else
         (mar:boolean-intersection shape1 shape2 #t))))


; A /\ B
(define (intersect.shape-shape shape1 shape2)
  (let ((val (rh-intersect shape1 shape2)))
    (if (void? val)
        (defer-intersect shape1 shape2)
        val)))

; A /\ d(B ? C)
(define (intersect.shape-defer shape defer)
  (intersect.defer-shape defer shape))

; d(A ? B) /\ C
(define (intersect.defer-shape defer shape)
  ; d(A /\ B) /\ C
  (define (intersect.defer-intersect-shape a b c)
    ; = A /\ C /\ B
    (define (intersect1 a b c)
      (let ((a-copy (mar:copy a))
            (c-copy (mar:copy c)))
        (let ((val1 (intersect a-copy c-copy)))
          (cond ((defer-intersect? val1)
                 (delete a-copy)
                 (delete c-copy)
                 (defer-intersect (defer-intersect a c) b))
                (else
                 (let ((val2 (intersect val1 b)))
                   (cond ((defer-intersect? val2)
                          (delete val1)
                          (defer-intersect (defer-intersect a c) b))
                         (else
                          (delete a)
                          (delete c)
                          val2))))))))
    
    ; = B /\ C /\ A
    (define (intersect2 a b c)
      (let ((b-copy (mar:copy b))
            (c-copy (mar:copy c)))
        (let ((val1 (intersect b-copy c-copy)))
          (cond ((defer-intersect? val1)
                 (delete b-copy)
                 (delete c-copy)
                 (defer-intersect (defer-intersect b c) a))
                (else
                 (let ((val2 (intersect val1 a)))
                   (cond ((defer-intersect? val2)
                          (delete val1)
                          (defer-intersect (defer-intersect b c) a))
                         (else
                          (delete b)
                          (delete c)
                          val2))))))))
    
    (let ((val (intersect1 a b c)))
      (if (defer-intersect? val)
          (intersect2 a b c)
          val)))
  
  ; d(A - B) /\ C
  (define (intersect.defer-subtract-shape a b c)
    (error 'intersect.defer-subtract-shape "Not implemeneted"))
  
  ; d(A U B) /\ C
  (define (intersect.defer-union-shape a b c)
    (error 'intersect.defer-union-shape "Not implemented"))
  
  (match defer
    ((defer-intersect a b)
     (intersect.defer-intersect-shape a b shape))
    ((defer-subtract a b)
     (intersect.defer-subtract-shape a b shape))
    ((defer-union a b)
     (intersect.defer-union-shape a b shape))))

; d(A ? B) /\ d(C ? D)
(define (intersect.defer-defer defer1 defer2)
  (error 'intersect.defer-defer "Not implemented"))

(define (dispatch-defer-intersect shape1 shape2)
  (defer-dispatch
    shape1
    shape2
    intersect.shape-shape
    intersect.shape-defer
    intersect.defer-shape
    intersect.defer-defer))

(define (intersect shape1 shape2)
  ((dispatch-defer-intersect shape1 shape2) shape1 shape2))

; /intersect


(define (join shapes)
  (mar:join-curves shapes #t))


; loft

(define (loft-curves shapes closed?)
  (mar:add-loft-surface shapes closed?))

(define (loft-borders shapes)
  (map
   (λ (shape)
     (if (mar:is-surface? shape)
         (join (mar:duplicate-surface-border shape))
         shape))
   shapes))

;(define (loft-surfaces shapes closed? surfaces)
;  (displayln "Loft:")
;  (displayln (format "shapes (~A) ~A" (length shapes) shapes))
;  (displayln (format "surfaces (~A) ~A" (length surfaces) surfaces))
;  (displayln "----------------------")
;  (let* ((lofted-curves (loft-curves (loft-borders shapes) closed?))
;         (lofted-surfaces (cons lofted-curves surfaces)))
;    (with-handlers ((exn?
;                     (λ (e)
;                       (displayln "Loft warning: surfaces may not appear in the lofted shape")
;                       ;(map delete surfaces)
;                       lofted-curves)))
;      (reduce (λ (s ss) (mar:join-surfaces (cons s ss) #t)) lofted-surfaces))))

; edit: wait for McNeel's email
(define (loft-surfaces shapes closed? surfaces)
  (map delete surfaces)
  (mar:cap-planar-holes (loft-curves (loft-borders shapes) closed?)))

(define (loft closed? shapes)
  (let ((surfaces (map mar:copy (filter mar:is-surface? shapes))))
    (if (empty? surfaces)
        (loft-curves shapes closed?)
        (loft-surfaces shapes closed? surfaces))))

; /loft


(define (move position shape)
  (if (eq-c position u0)
      shape
      (mar:move shape position)))

(define (rotate angle normal shape)
  (mar:rotate
   shape
   u0
   (degrees<-radians angle)
   normal
   false))

(define (scale type size shape/shapes)
  (match type
    ((center-scaling-type)
     (error 'scale "Rhino scale: center not implemented"))
    ((origin-scaling-type)
     (if (list? shape/shapes)
         (map
          (λ (shape) (mar:scale shape u0 size false))
          shape/shapes)
         (mar:scale shape/shapes u0 size false)))))


; subtract

(define (rh-subtract shape1 shape2)
  (mar:boolean-difference shape1 shape2 #t))


; A - B
(define (subtract.shape-shape shape1 shape2)
  (let ((val (rh-subtract shape1 shape2)))
    (if (void? val)
        (defer-subtract shape1 shape2)
        val)))

; A - d(B ? C)
(define (subtract.shape-defer shape defer)
  ; A - d(B /\ C)
  (define (subtract.shape-defer-intersect a b c)
    (error 'subtract.shape-defer-intersect "Not implemented"))
  
  ; A - d(B - C)
  ; = (A /\ C) U (A - B)
  (define (subtract.shape-defer-subtract a b c)
    (let ((a-copy1 (mar:copy a))
          (c-copy (mar:copy c)))
      (let ((val1 (intersect a-copy1 c-copy)))
        (cond ((defer-intersect? val1)
               (delete a-copy1)
               (delete c-copy)
               (defer-union
                 (defer-intersect a c)
                 (defer-subtract a b)))
              (else
               (let ((a-copy2 (mar:copy a))
                     (b-copy (mar:copy b)))
                 (let ((val2 (subtract a-copy2 b-copy)))
                   (cond ((defer-subtract? val2)
                          (delete val1)
                          (delete a-copy2)
                          (delete b-copy)
                          (defer-union
                            (defer-intersect a c)
                            (defer-subtract a b)))
                         (else
                          (let ((val3 (union val1 val2)))
                            (cond ((defer-union? val3)
                                   (delete val1)
                                   (delete val2)
                                   (defer-union
                                     (defer-intersect a c)
                                     (defer-subtract a b)))
                                  (else
                                   (delete a)
                                   (delete b)
                                   (delete c)
                                   val3))))))))))))
  
  ; A - d(B U C)
  (define (subtract.shape-defer-union a b c)
    (error 'subtract.shape-defer-union "Not implemented"))
  
  (match defer
    ((defer-intersect a b)
     (subtract.shape-defer-intersect shape a b))
    ((defer-subtract a b)
     (subtract.shape-defer-subtract shape a b))
    ((defer-union a b)
     (subtract.shape-defer-union shape a b))))

; d(A ? B) - C
(define (subtract.defer-shape defer shape)
  ; d(A /\ B) - C
  (define (subtract.defer-intersect-shape a b c)
    (error 'subtract.defer-intersect-shape "Not implemented"))
  
  ; d(A - B) - C
  ; = A - C - B
  (define (subtract.defer-subtract-shape a b c)
    (let ((a-copy (mar:copy a))
          (c-copy (mar:copy c)))
      (let ((val1 (subtract a-copy c-copy)))
        (cond ((defer-subtract? val1)
               (delete a-copy)
               (delete c-copy)
               (defer-subtract (defer-subtract a c) b))
              (else
               (let ((val2 (subtract val1 b)))
                 (cond ((defer-subtract? val2)
                        (delete val1)
                        (defer-subtract (defer-subtract a c) b))
                       (else
                        (delete a)
                        (delete c)
                        val2))))))))
  
  ; d(A U B) - C
  (define (subtract.defer-union-shape a b c)
    (error 'subtract.defer-union-shape "Not implemented"))
  
  (match defer
    ((defer-intersect a b)
     (subtract.defer-intersect-shape a b shape))
    ((defer-subtract a b)
     (subtract.defer-subtract-shape a b shape))
    ((defer-union a b)
     (subtract.defer-union-shape a b shape))))

; d(A ? B) - d(C ? D)
(define (subtract.defer-defer defer1 defer2)
  (error 'subtract.defer-defer "Not implemented"))

(define (dispatch-defer-subtract shape1 shape2)
  (defer-dispatch
    shape1
    shape2
    subtract.shape-shape
    subtract.shape-defer
    subtract.defer-shape
    subtract.defer-defer))

; edit: replace void with an exception
(define (subtract shape1 shape2)
  ((dispatch-defer-subtract shape1 shape2) shape1 shape2))

; /subtract


; union

(define (rh-union shape1 shape2)
  (mar:boolean-union shape1 shape2 #t))


; A U B
(define (union.shape-shape shape1 shape2)
  (let ((val (rh-union shape1 shape2)))
    (if (void? val)
        (defer-union shape1 shape2)
        val)))

; A U d(B ? C)
(define (union.shape-defer shape defer)
  (union.defer-shape defer shape))

; d(A ? B) U C
(define (union.defer-shape defer shape)
  ; d(A /\ B) U C
  (define (union.defer-intersect-shape a b c)
    (error 'union.defer-intersect-shape "Not implemented"))
  
  ; d(A - B) U C
  (define (union.defer-subtract-shape a b c)
    (error 'union.defer-subtract-shape "Not implemented"))
  
  ; d(A U B) U C
  (define (union.defer-union-shape a b c)
    ; = A U C U B
    (define (union1 a b c)
      (let ((a-copy (mar:copy a))
            (c-copy (mar:copy c)))
        (let ((val1 (union a-copy c-copy)))
          (cond ((defer-union? val1)
                 (delete a-copy)
                 (delete c-copy)
                 (defer-union (defer-union a c) b))
                (else
                 (let ((val2 (union val1 b)))
                   (cond ((defer-union? val2)
                          (delete val1)
                          (defer-union (defer-union a c) b))
                         (else
                          (delete a)
                          (delete c)
                          val2))))))))

    ; = B U C U A
    (define (union2 a b c)
      (let ((b-copy (mar:copy b))
            (c-copy (mar:copy c)))
        (let ((val1 (union b-copy c-copy)))
          (cond ((defer-union? val1)
                 (delete b-copy)
                 (delete c-copy)
                 (defer-union (defer-union b c) a))
                (else
                 (let ((val2 (union val1 a)))
                   (cond ((defer-union? val2)
                          (delete val1)
                          (defer-union (defer-union b c) a))
                         (else
                          (delete b)
                          (delete c)
                          val2))))))))

    (let ((val (union1 a b c)))
      (if (defer-union? val)
          (union2 a b c)
          val)))
  
  (match defer
    ((defer-intersect a b)
     (union.defer-intersect-shape a b shape))
    ((defer-subtract a b)
     (union.defer-subtract-shape a b shape))
    ((defer-union a b)
     (union.defer-union-shape a b shape))))

; d(A ? B) U d(C ? D)
(define (union.defer-defer defer1 defer2)
  (error 'union.defer-defer "Not implemented"))

(define (dispatch-defer-union shape1 shape2)
  (defer-dispatch
    shape1
    shape2
    union.shape-shape
    union.shape-defer
    union.defer-shape
    union.defer-defer))

(define (union shape1 shape2)
  ((dispatch-defer-union shape1 shape2) shape1 shape2))

; /union


(define (thicken distance shape)
  ;  (let ((s1 (mar:copy shape))
  ;        (s2 (mar:offset-surface shape distance)))
  ;    (let ((s1-border (mar:duplicate-surface-border s1))
  ;          (s2-border (mar:duplicate-surface-border s2)))
  ;      (list
  ;       (surface s1)
  ;       (surface s2)
  ;       (mar:add-loft-surface (list s1-border s2-border) #f)))))
  (mar:offset-surface-solid shape distance))


; lang

(define (align type shape)
  (define (align-shape-center shape)
    (let ((bb (mar:object-bounding-box shape)))
      (move (symmetric (bbox-center bb)) shape)))
  
  (define (align-shape bb-fn xyz-fn shape)
    (let* ((bb (mar:object-bounding-box shape))
           (p (bb-fn bb)))
      (move (xyz-fn (symmetric p) 0 0) shape)))
  
  (match type
    ((center-align-type) (align-shape-center shape))
    ((x-pos-align-type) (align-shape bbox-x-pos yz shape))
    ((x-neg-align-type) (align-shape bbox-x-neg yz shape))
    ((y-pos-align-type) (align-shape bbox-y-pos xz shape))
    ((y-neg-align-type) (align-shape bbox-y-neg xz shape))
    ((z-pos-align-type) (align-shape bbox-z-pos xy shape))
    ((z-neg-align-type) (align-shape bbox-z-neg xy shape))
    (else
     (raise-backend-exn (align-type-msg align)))))

(define (bbox shape)
  (begin0
    (mar:object-bounding-box shape)
    (delete shape)))


; on

; edit: duplicated from ac-backend.rkt
(define (on-shape corner-fn bbox-fn shape1 shape2)
  (let* ((shape1-bb (mar:object-bounding-box shape1))
         (shape2-bb (mar:object-bounding-box shape2))
         (corner (corner-fn shape2-bb))
         (center (bbox-fn shape1-bb corner)))
    (mar:join-shapes
     (mar:move shape1 (bbox-center shape1-bb) center)
     shape2)))

(define (on type shapes)
  (match type
    ((x-pos-on-type) (reducer (cλ on-shape bbox-x-pos bbox-center<-left) shapes))
    ((x-neg-on-type) (reducer (cλ on-shape bbox-x-neg bbox-center<-right) shapes))
    ((y-pos-on-type) (reducer (cλ on-shape bbox-y-pos bbox-center<-front) shapes))
    ((y-neg-on-type) (reducer (cλ on-shape bbox-y-neg bbox-center<-back) shapes))
    ((z-pos-on-type) (reducer (cλ on-shape bbox-z-pos bbox-center<-bottom) shapes))
    ((z-neg-on-type) (reducer (cλ on-shape bbox-z-neg bbox-center<-top) shapes))))

; /on


; par

(define (par-circle shape)
  (let ((center (mar:circle-center shape))
        (normal (mar:circle-normal shape))
        (radius (mar:circle-radius shape)))
    (let ((translation
           (apply m.translate (list-of-coord center)))
          (rotation
           (m-rotate (angle-c uz normal (cross-c uz normal)) (cross-c uz normal))))
      (make-transformation-parametric
       (make-transformation-parametric
        (make-circle-curve radius)
        rotation)
       translation))))

(define (par shape)
  (finally
   (cond ((circle? shape)
          (par-circle shape))
         (else
          (error 'par "Unhandled par type")))
   (λ () (delete shape))))

(define (view type projection-type lens shape/shapes)
  (displayln "View: Old implementation")
  (match type
    ((auto-view-type direction)
     (error 'view "Not implemented"))
    ((manual-view-type center target)
     (let ((perspective (match projection-type
                          ((ortho-projection-type) mar:view-projection-mode-parallel)
                          ((perspective-projection-type) mar:view-projection-mode-perspective))))
       (mar:view center target perspective lens)))))


; /par


; properties

(define curve-begin-coord mar:curve-begin-coord)
(define curve-end-coord mar:curve-end-coord)

(define surface-curvature mar:surface-curvature)
(define surface-domain mar:surface-domain)


; cad

; edit: optimize with node? similarly to AutoCAD
(define (begin-draw exp)
  (enable-redraw #f))

(define (delete-shape shape)
  (mar:delete shape))

(define (delete-shapes)
  (map mar:delete (mar:get-shapes)))

; edit: optimize with node? similarly to AutoCAD
(define (end-draw exp)
  (enable-redraw #t))

(define (get-shapes)
  (mar:get-shapes))

(define (render-shape width height path)
  (mar:render width height path))

; rhino

(define circle? mar:is-circle?)
(define get-circle-center mar:circle-center)
(define get-circle-normal mar:circle-normal)
(define get-circle-radius mar:circle-radius)

(define copy mar:copy)
(define delete mar:delete)
(define enable-redraw mar:enable-redraw)
(define delete-all-objects mar:delete-all)
(define get-object mar:get-object)

(define (layer layer)
  (unless (mar:is-layer? layer)
    (mar:add-layer layer))
  (mar:current-layer layer))

(define is-object? mar:is-object?)


; backend

(define-proxy rhino-proxy
  ((evaluate expr) #f)
  ((evaluate-toplevel expr) #f)
  
  ; points
  
  ((point c) (point c))
  
  
  ; lines
  
  ((arc angle radius) (arc angle radius))
  ((elliptical-arc angle x-radius y-radius) (elliptical-arc angle x-radius y-radius))
  ((ellipse x-radius y-radius) (ellipse x-radius y-radius))
  ((line closed? coords) (line closed? coords))
  ((nurbs-curve controls knots) (error 'nurbs-curve "Not implemented"))
  ((spline closed? cs type) (spline closed? cs type))
  
  
  ; surfaces
  
  ((donut inner-radius outer-radius) (error 'donut "Not implemented"))
  ((ngon width sides) (error 'ngon "Not implemented"))
  ((nurbs-surface controls u-knots v-knots) (error 'nurbs-surface "Not implemented"))
  ((star width sides stride) (error 'star "Not implemented"))
  ((surface shapes) (surface shapes))
  
  
  ; solids
  
  ((box width length height) (box width length height))
  ((cone radius height) (cone radius height))
  ((cone-frustrum base-radius top-radius height) (cone-frustrum base-radius top-radius height))
  ((cylinder radius height) (cylinder radius height))
  ((pyramid width sides height) (pyramid width sides height))
  ((sphere radius) (sphere radius))
  
  
  ; generic shapes
  
  ((circle type radius) (circle type radius))
  ((rectangle type width length) (rectangle type width length))
  
  
  ; transformations
  
  ((extrude length shape) (extrude length shape))
  ((intersect shape1 shape2) (intersect shape1 shape2))
  ((join shapes) (join shapes))
  ((loft closed? shapes) (loft closed? shapes))
  ((move position shape) (move position shape))
  ((offset distance shape) (error 'offset "Not implemented"))
  ((rotate angle normal shape) (rotate angle normal shape))
  ((scale type size shape/shapes) (scale type size shape/shapes))
  ((subtract shape1 shape2) (subtract shape1 shape2))
  ((sweep path shape) (error 'sweep "Not implemented"))
  ((thicken distance shape) (thicken distance shape))
  ((union shape1 shape2) (union shape1 shape2))
  
  
  ; lang
  
  ((align type shape) (align type shape))
  ((bbox shape) (bbox shape))
  ((on type shapes) (on type shapes))
  ((par shape) (par shape))
  ((view type projection-type lens shape/shapes) (view type projection-type lens shape/shapes))
  
  
  ; properties
  
  ((curve-begin-coord shape) (curve-begin-coord shape))
  ((curve-end-coord shape) (curve-end-coord shape))
  
  ((surface-curvature shape) (surface-curvature shape))
  ((surface-domain shape) (surface-domain shape))
  
  
  ; cad
  
  ((begin-draw exp) (begin-draw exp))
  ((begin-undo-mark) (error 'begin-undo-mark "Not implemented"))
  ((delete-shape shape) (delete-shape shape))
  ((delete-shapes shape) (delete-shapes))
  ((end-draw exp) (end-draw exp))
  ((end-undo-mark) (error 'end-undo-mark "Not implemented"))
  ((get-shapes) (get-shapes))
  ((render-shape width height path) (render-shape width height path))
  ((undo) (error 'undo "Not implemented")))

(define (load-rhino-proxy)
  (mar:load-rhino-marshall)
  (letrec ((proxy
            (make-rhino-proxy
             #:evaluate (λ (expr) (replace-defers (generic-evaluate proxy expr)))
             #:evaluate-toplevel (λ (expr) (replace-defers (generic-evaluate-toplevel proxy expr))))))
    proxy))